package Sokoban::Parser;
use 5.014002;
use Storable qw(dclone freeze thaw);
use Data::Dump qw(dump);
use List::MoreUtils qw(any all minmax first_index uniq);
use List::Util qw(sum min max);
use Math::Combinatorics;
use Time::HiRes qw(tv_interval gettimeofday);
use Carp;
use Sokoban::Handy qw(boxply);

use constant {
    OLEFT  => 0,
    OUP    => 1,
    ORIGHT => 2,
    ODOWN  => 3,
    POZ    => 0,
    SOL    => 1,
    SCORE  => 2,
    NO     => !1,
    YES    => !0
};

sub new {
    my( $class, $hra ) = @_;
    my $self = bless {}, $class;
    $self->{bestbet} = undef;
    $self->{bestlen} = undef;
    $self->{target} = [];
    $self->{box}    = [];
    $self->{dijk}   = [];
    $self->parse($hra);
    $self->smery;
    $self->normalize;
    $self->forbid;
    $self->patterns;
    $self->{sm}{-1}            = 'L';
    $self->{sm}{1}             = 'R';
    $self->{sm}{ -$self->{C} } = 'U';
    $self->{sm}{ $self->{C} }  = 'D';
    $self->{s} = [qw'l u r d'];
    return $self;
}



sub idx {
    my( $self, $r, $c ) = @_;
    return $r * $self->{C} + $c;
}
sub coord {
    my( $self, $x ) = @_;
    use integer;
    return ( $x / $self->{C}, $x % $self->{C} );
}

sub parse {
    my( $self, $hra ) = @_;
    $hra =~ tr/# .$@+*/9034587/;
    my @board = map { [ split //, $_ ] } split /[\r\n]+/, $hra;
    my $mx = max map { $#{$_} } @board;
    foreach my $row (@board) {
        my $i = 0;
        $row->[ $i++ ] = 9 while ( $row->[$i] == 0 );
        if ( $#{$row} < $mx ) {
            $row->[$_] = 9 for ( $#{$row} .. $mx );
        }
    }
    $self->{board} = [@board];
    my $rows = $self->{rows} = $#board;
    my $cols = $self->{cols} = $mx;
    $self->{C}      = $mx + 1;

    for my $r ( 0 .. $rows ) {
        for my $c ( 0 .. $cols ) {
            next if $board[$r]->[$c] == 9;
            my $x = $self->idx( $r, $c );
            $self->{maze}{$x} = {};
            push $self->{dijk}, $x;
            next if $board[$r]->[$c] == 0;
            given ( $board[$r]->[$c] ) {
                when (3) {
                    $self->{maze}{$x}{target} = 1;
                    push $self->{target}, $x;
                }
                when (4) {
                    push $self->{box}, $x;
                    $self->{board}[$r][$c] = 0;
                }
                when (5) {
                    $self->{player} = $x;
                    $self->{board}[$r][$c] = 0;
                }
                when (7) {
                    push $self->{box},    $x;
                    push $self->{target}, $x;
                    $self->{board}[$r][$c] = 3;
                }
                when (8) {
                    $self->{player} = $x;
                    push $self->{target}, $x;
                    $self->{board}[$r][$c] = 3;
                }
            }
        }
    }
    $self->{nbox} = 1 + $#{ $self->{box} };
}

sub smery {
    my($self) = @_;
    for my $r ( 0 .. $self->{rows} ) {
        for my $c ( 0 .. $self->{cols} ) {
            next if $self->{board}[$r][$c] == 9;
            my $x = $self->idx( $r, $c );
            if ( $c > 0 ) {
                $self->{maze}{$x}{o}[0] = $self->idx( $r, $c - 1 ) if $self->{board}[$r][ $c - 1 ] != 9;
            }
            if ( $r > 0 ) {
                $self->{maze}{$x}{o}[1] = $self->idx( $r - 1, $c ) if $self->{board}[ $r - 1 ][$c] != 9;
            }
            if ( $c < $self->{cols} ) {
                $self->{maze}{$x}{o}[2] = $self->idx( $r, $c + 1 ) if $self->{board}[$r][ $c + 1 ] != 9;
            }
            if ( $r < $self->{rows} ) {
                $self->{maze}{$x}{o}[3] = $self->idx( $r + 1, $c ) if $self->{board}[ $r + 1 ][$c] != 9;
            }
            $self->{maze}{$x}{o}[$_] //= 0 for ( 0 .. 3 );
            my $o = $self->{maze}{$x}{o};
            $self->{maze}{$x}{oo} =   [ [ $o->[OLEFT], $o->[ORIGHT] ], [ $o->[ORIGHT], $o->[OLEFT] ], [ $o->[OUP], $o->[ODOWN] ], [ $o->[ODOWN], $o->[OUP] ] ];

        }
    }
}
sub step {
    my( $self, $bx ) = @_;
    my( $x, $w, $o, @p, @s );
    $x                 = $bx->[0];
    confess "no valid x [$x]" unless $x;
    $self->{paths}{$x} = $bx->[1];
    $w                 = 1 + $self->{dijkstra}{$x};
    $o                 = $self->{maze}{$x}{o};
    @p                 = ();
    for ( 0 .. 3 ) {
        next unless $o->[$_];
        next unless $self->{dijkstra}{ $o->[$_] } > $w;
        push @p, [ $o->[$_], $bx->[1] . $self->{s}[$_] ];
        $self->{dijkstra}{ $o->[$_] } = $w;
    }
    return @p;
}

sub cesty {
    my( $self, $box, $ply ) = @_;
    confess "nobox" unless ref $box;
    confess "no valid ply [$ply]" unless $ply;
    $self->{paths}    = {};
    $self->{dijkstra} = {};
    for my $x (@{$self->{dijk}} ) {
        $self->{dijkstra}{$x} = 10000;
    }
    $self->{dijkstra}{$_} = 0 for ( @{$box} );
    $self->{dijkstra}{$ply} = 1;
    my @pokr = $self->step( [ $ply, '' ] );
    while (@pokr) { push @pokr, $self->step( shift @pokr ) }
    delete $self->{dijkstra};
    return delete $self->{paths};
}

sub normalize {
    my($self) = @_;
    my $cesty = $self->cesty( [], $self->{player} );
    my @ven = grep { !exists( $cesty->{$_} ) } @{$self->{dijk}};
    $self->{dijk} = [ grep { !( $_ ~~ @ven ) } @{ $self->{dijk} } ];
    for (@ven) {
        delete $self->{maze}{$_};
        my( $r, $c ) = $self->coord($_);
        $self->{board}[$r][$c] = 9;
    }
}

sub elements {
    my($self) = @_;
    return ( keys $self->{maze} );
}
sub ingame {
    my( $self, $x ) = @_;
    return exists $self->{maze}{$x};
}

sub pullstep {
    my( $self, $y, $z, $w ) = @_;
    if ( $self->ingame($z) and $self->ingame($y) and $self->{dijkstra}{$y} > $w ) {
        $self->{dijkstra}{$y} = $w;
        return $y;
    }
    return ();
}
sub pull {
    my( $self, $x ) = @_;
    my( $y, $z );
    my $w  = 1 + $self->{dijkstra}{$x};
    my @s  = ();
    my $c  = $self->{C};
    my $cc = 2 * $c;
    push @s, $self->pullstep( $x - $c, $x - $cc, $w ),
      $self->pullstep( $x + $c, $x + $cc, $w ),
      $self->pullstep( $x - 1,  $x - 2,   $w ),
      $self->pullstep( $x + 1,  $x + 2,   $w );
    return @s;
}


sub checkpull {
    my( $self, $x ) = @_;
    $self->{dijkstra} = {};
    $self->{dijkstra}{$_} = 10000 for ( @{$self->{dijk}} );
    $self->{dijkstra}{$x} = 1;
    my @pokr = $self->pull($x);
    while (@pokr) { push @pokr, $self->pull( shift @pokr ) }
    return delete $self->{dijkstra};
}
sub forbidden {
    my( $self, $x ) = @_;
    return ( grep { $self->{maze}{$_}{forbidden} } $self->elements );
}
sub avg(@) {
    my $s = sum @_;
    my $p = scalar(@_);
    return sprintf '%.0f',$s/$p;
}
sub forbid {
    my $self      = shift;
    my $forbidden = {};
    $forbidden->{$_} = 1 for $self->elements;
    foreach my $x ( @{ $self->{target} } ) {
        my $djk = $self->checkpull($x);
        map { $self->{distance}{$_}{$x} = $djk->{$_} - 1 } grep { $djk->{$_} != 10_000 } $self->elements;
        delete $forbidden->{$_} for grep { $djk->{$_} != 10_000 } grep { $_ != $x } $self->elements;
    }
    delete $forbidden->{$_} for ( @{ $self->{target} } );
    $self->{maze}{$_}{forbidden} = 1 for ( keys $forbidden );
    $self->{distance}{$_} = avg(values $self->{distance}{$_}) for keys $self->{distance};
    $self->{distance}{$_} = 0 for values $self->{target};
    return;
}
sub nine {
    my( $self, $x ) = @_;
    my $u = $x - $self->{C};
    my $d = $x + $self->{C};
    return ( $u - 1, $u, $u + 1, $x - 1, $x, $x + 1, $d - 1, $d, $d + 1 );
}
sub desk {
    my( $self, $x ) = @_;
    my( $r, $c );
    return 9 unless $self->ingame($x);
    ( $r, $c ) = $self->coord($x);
    return $self->{board}[$r][$c];
}

sub deskpattern {
    my( $self, $x ) = @_;
    my $ar = [ map { $self->desk($_) } $self->nine($x) ];
    $ar->[4] += 4;
    return $ar;
}
sub rotate {
    my( $self, $p ) = @_;
    my @r = split //, $p;
    my @pokr = ($p);
    push @pokr, join "", map { $r[$_] } qw(0 3 6 1 4 7 2 5 8);
    push @pokr, join "", map { $r[$_] } qw(2 1 0 5 4 3 8 7 6);
    push @pokr, join "", map { $r[$_] } qw(2 5 8 1 4 7 0 3 6);
    push @pokr, join "", map { $r[$_] } qw(6 3 0 7 4 1 8 5 2);
    push @pokr, join "", map { $r[$_] } qw(6 7 8 3 4 5 0 1 2);
    push @pokr, join "", map { $r[$_] } qw(8 5 2 7 4 1 6 3 0);
    push @pokr, join "", map { $r[$_] } qw(8 7 6 5 4 3 2 1 0);
    return @pokr;
}

sub blocked {
    my( $self, $p ) = @_;
    my @v = $self->rotate($p);
    return 1 if grep { /^....(?:[47]994|49.9|499[47])./o } @v;
    return 1 if grep { /^...(?:[479][479].(?:[479]4|4[479])|(?:[479]4|4[479]).[479][479])/o } @v;
    return 1 if grep { /^..9.(?:[479][479]94|[479]49[479]|4[479]9[479])./o } @v;
    return 1 if grep { /^..9[79][79]4[79][79]./o } @v;
    return '';
}
sub include {
    my($self,$box,$pattern) = @_;
    foreach (@{$pattern}) {
        return '' unless $_ ~~ $box;
    }
    return 1;
}


sub anyall {
    my( $self, $box, $patt ) = @_;
    return '' unless ref $patt;
    return '' if $patt ~~ [];
    my @test =  @{$patt};
    return '' unless @test;
    foreach my $t (@test) {
        return 1 if $self->include($box,$t);
    }
    return '';
}
sub patterns {
    my($self) = @_;
    my( @box, $p, @data );
    my $fb = [ $self->forbidden ];
    my $pocet;
    foreach my $x ( $self->elements ) {
        next if $self->{maze}{$x}{forbidden};
        @box  = $self->nine($x);
        $p    = $self->deskpattern($x);
        @data = grep { $p->[$_] ~~ [ 0, 3 ] } keys $p;
        $pocet = scalar(@data) > $#{$self->{box}} ? $#{$self->{box}} : scalar (@data);
        for my $count ( 1 .. $pocet ) {
            my $combinat = Math::Combinatorics->new( count => $count, data => [@data], );
            while ( my @combo = $combinat->next_combination ) {
                map { $p->[$_] += 4 } @combo;
                my $s = join "", @{$p};
                map { $p->[$_] -= 4 } @combo;
                $self->blocked($s) or next;
                my @f = ();
                for my $i ( 0 .. 3, 5 .. 8 ) {
                    ( substr( $s, $i, 1 ) ~~ [ 4, 7 ] ) and push @f, $box[$i];
                }
                push @{ $self->{maze}{$x}{patterns} }, [@f] if @f;
            }
        }
        $self->{maze}{$x}{patterns} or next;
        my @patterns = sort { $#{$a} <=> $#{$b} } @{ $self->{maze}{$x}{patterns} };
        @patterns = grep {
            !( any { $_ ~~ $fb } @{$_} )
        } @patterns;
        unless (@patterns) {
            delete $self->{maze}{$x}{patterns};
            next;
        }
        my @zbytek = ();
        push @zbytek, shift @patterns;
        foreach my $p (@patterns) {
            next if $self->anyall( $p, [@zbytek] );
            push @zbytek, [ @{$p} ];
        }
        $self->{maze}{$x}{patterns} = [@zbytek] if @zbytek;
    }
    return;
}

sub tostring {
    my( $self, $pozice ) = @_;
    my( $r, $c );
    my( $box, $ply ) = boxply($pozice);
    my $board = dclone( $self->{board} );
    foreach my $x ( values $box ) {
        ( $r, $c ) = $self->coord($x);
        $board->[$r][$c] += 4;
    }
    ( $r, $c ) = $self->coord($ply);
    $board->[$r][$c] += 5;
    my $buffer = join "\n", map { join "", @{$_} } @{$board};
    $buffer =~ tr/9034587/# .$@+*/;
    return "\n$buffer";
}

sub imshow {
    my ($self,$pozice) = splice(@_,0,2);
    say {*STDERR} $self->tostring($pozice);
    say {*STDERR} join ", ",  @_ if @_;
}

sub contorexit {
    my($self) = @_;
    print {*STDOUT} "soko:> ";
    my $answ = <STDIN>;
    exit if $answ =~ /q/i;
    return;
}

sub show {
    my($self,$pozice) = splice(@_,0,2);
    $self->imshow($pozice,@_);
    $self->contorexit;
}

sub chrono {
    my $self = shift;
    map { $self->{$_} = [gettimeofday] } @_;
    return;
}

sub elapsed {
    my( $self, $timer, $limit ) = @_;
    unless ( $self->{$timer} ) {
        $self->chrono($timer);
        return '';
    }
    if ( tv_interval( $self->{$timer} ) >= $limit ) {
        $self->chrono($timer);
        return 1;
    }
    return '';
}
sub interval {
    my( $self, $timer ) = @_;
    return tv_interval( $self->{$timer} );
}

sub score {
    my( $self, $box, $x ) = @_;
    my $sc = 0;
    $sc = sum map {$self->{distance}{$_}} @{$box};
    $sc += $self->{distance}{$x};
    return $sc;
}


sub solved {
    my($self) = @_;
    return defined $self->{bestbet};
}

sub worse {
    my( $self, $sollen ) = @_;
    return 1 if $sollen > 2000;
    return '' unless $self->solved;
    return '' if $sollen < $self->{bestlen};
    return 1;
}

sub checkstep {
    my( $self, $bx ) = @_;
    my( $x, $w, $o, @p, @s, $i );
    $x                 = $bx;
    $self->{check}{$x} = 1;
    $w                 = 1 + $self->{djk}{$x};
    $o                 = $self->{maze}{$x}{o};
    @p                 = ();
    foreach $i ( grep {$_} @{$o} ) {
        next unless $self->{djk}{ $i } > $w;
        push @p, $i;
        $self->{djk}{$i} = $w;
    }
    return @p;
}

sub checkpath {
    my( $self, $box, $ply ) = @_;
    confess "nobox" unless ref $box;
    $self->{check} = {};
    $self->{djk}   = {};
    for my $x ( values $self->{dijk} ) {
        $self->{djk}{$x} = 10000;
    }
    $self->{djk}{$_} = 0 for ( @{$box} );
    $self->{djk}{$ply} = 1;
    my @pokr = $self->checkstep($ply);
    while (@pokr) { push @pokr, $self->checkstep( shift @pokr ) }
    delete $self->{djk};
    return delete $self->{check};
}

sub mypozice {
    my( $box, $ply ) = @_;
    my $s = pack 'W*', ( @{$box}, $ply );
    return $s;
}

sub isforbidden {
    my($self,$x) = @_;
    confess "isforbidden: no {$x} in maze" unless exists $self->{maze}{$x};
    return exists $self->{maze}{$x}{forbidden};
}

sub canmove {
    my($self,$cesty,$box,$x,$y,$z) = @_;
    return NO unless $y;
    return NO unless $z;
    return NO if $self->isforbidden($y);
    return NO if $y ~~ $box;
    return NO unless $z ~~ $cesty;
    return YES;
}


sub start {
    my($self) = @_;
    my $players = {};
    $self->{reseni} = [];
    foreach my $x ( values $self->{target} ) {
        foreach my $y ( values $self->{maze}{$x}{o} ) {
            next unless $y;
            next if $y ~~ $self->{target};
            $players->{$y} = 1;
        }
    }
    foreach my $ply ( keys $players ) {
        my $pozice = mypozice( $self->{target}, $ply );
        push $self->{reseni}, $pozice;
    }
}



1;

__END__
